home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / gcl-1.000 / gcl-1 / gcl-1.0 / cmpnew / cmpcall.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1994-05-07  |  20.2 KB  |  587 lines
  1. ;;; CMPCALL  Function call.
  2. ;;;
  3. ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa
  4.  
  5. ;; This file is part of GNU Common Lisp, herein referred to as GCL
  6. ;;
  7. ;; GCL is free software; you can redistribute it and/or modify it under
  8. ;;  the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by
  9. ;; the Free Software Foundation; either version 2, or (at your option)
  10. ;; any later version.
  11. ;; 
  12. ;; GCL is distributed in the hope that it will be useful, but WITHOUT
  13. ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  14. ;; FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Library General Public 
  15. ;; License for more details.
  16. ;; 
  17. ;; You should have received a copy of the GNU Library General Public License 
  18. ;; along with GCL; see the file COPYING.  If not, write to the Free Software
  19. ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  20.  
  21.  
  22. (in-package 'compiler)
  23.  
  24. (defvar *ifuncall* nil)
  25.  
  26.  
  27. (eval-when (compile eval)
  28. (defmacro link-arg-p (x)
  29.   `(let ((.u ,x))
  30.      (not (member .u '(character boolean long-float short-float)))))
  31. )
  32.  
  33. (defun fast-link-proclaimed-type-p (fname &optional args)
  34.   (and 
  35.        (symbolp fname)
  36.        (and (< (the fixnum(length args)) 64)
  37.         (or  (and (get fname 'fixed-args)
  38.               (listp args))
  39.          (and
  40.           (get fname 'proclaimed-function)
  41.           (link-arg-p (get fname 'proclaimed-return-type))
  42.           (dolist (v (get fname 'proclaimed-arg-types) t)
  43.               (or  (eq v '*)(link-arg-p v) (return nil))))))))
  44.  
  45. (si::putprop 'funcall 'c2funcall-aux 'wholec2)
  46. (si:putprop 'call-lambda 'c2call-lambda 'c2)
  47. (si:putprop 'call-global 'c2call-global 'c2)
  48.  
  49. ;;Like macro-function except it searches the lexical environment,
  50. ;;to determine if the macro is shadowed by a function or a macro.
  51. (defun cmp-macro-function (name &aux fd)
  52.   (cond ((setq fd (c1local-fun name))
  53.      (if (eq (car fd) 'call-local) nil  fd))
  54.     (t (macro-function name))))
  55.  
  56. (defun c1funob (fun &aux fd)
  57.   ;;; NARGS is the number of arguments.  If the number is unknown, (e.g.
  58.   ;;; in case of APPLY), then NARGS should be NIL.
  59.   (cond ((and (consp fun)
  60.           (symbolp (car fun))
  61.           (cmp-macro-function (car fun)))
  62.      (setq fun (cmp-macroexpand fun))))
  63.   (or
  64.    (and
  65.     (consp fun)
  66.     (or (and (eq (car fun) 'quote)
  67.              (not (endp (cdr fun)))
  68.              (endp (cddr fun))
  69.              (or (and (consp (cadr fun))
  70.                       (not (endp (cdadr fun)))
  71.                       (eq (caadr fun) 'lambda)
  72.                       (let ((*vars* nil) (*funs* nil) (*blocks* nil)
  73.                                          (*tags* nil))
  74.                            (let ((lambda-expr (c1lambda-expr (cdadr fun))))
  75.                                 (list 'call-lambda (cadr lambda-expr)
  76.                                       lambda-expr))))
  77.                  (and (symbolp (cadr fun))
  78.                       (or (and (setq fd (c1local-fun (cadr fun)))
  79.                                (eq (car fd) 'call-local)
  80.                                fd)
  81.                           (list 'call-global
  82.                                 (make-info
  83.                                  :sp-change
  84.                                  (null (get (cadr fun) 'no-sp-change)))
  85.                                 (cadr fun)))
  86.                       )))
  87.         (and (eq (car fun) 'function)
  88.              (not (endp (cdr fun)))
  89.              (endp (cddr fun))
  90.              (or (and (consp (cadr fun))
  91.                       (eq (caadr fun) 'lambda)
  92.                       (not (endp (cdadr fun)))
  93.                       (let ((lambda-expr (c1lambda-expr (cdadr fun))))
  94.                            (list 'call-lambda (cadr lambda-expr) lambda-expr))
  95.                       )
  96.                  (and (symbolp (cadr fun))
  97.                       (or (and (setq fd (c1local-fun (cadr fun)))
  98.                                (eq (car fd) 'call-local)
  99.                                fd)
  100.                           (list 'call-global
  101.                                 (make-info
  102.                                  :sp-change
  103.                                  (null (get (cadr fun) 'no-sp-change)))
  104.                                 (cadr fun)))
  105.                       )))))
  106.    (let ((x (c1expr fun)) (info (make-info :sp-change t)))
  107.         (add-info info (cadr x))
  108.         (list 'ordinary info x))
  109.    ))
  110.  
  111.  
  112. (defun c2funcall-aux(form &aux  (info (cadr form))
  113.                (funob (caddr form))
  114.                (args (cadddr form))
  115.                (loc (nth 4 form)))
  116.   (c2funcall funob args loc info))
  117.  
  118. (defvar  *use-sfuncall* t)
  119. (defvar *super-funcall* nil)
  120.  
  121. (defun c2funcall (funob args &optional loc info)
  122.  
  123.   ;;; Usually, ARGS holds a list of forms, which are arguments to the
  124.   ;;; function.  If, however, the arguments are already pushed on the stack,
  125.   ;;; ARGS should be set to the symbol ARGS-PUSHED.
  126.   (case (car funob)
  127.     (call-global (c2call-global (caddr funob) args loc t))
  128.     (call-local (c2call-local (cddr funob) args))
  129.     (call-lambda (c2call-lambda (caddr funob) args))
  130.     (ordinary        ;;; An ordinary expression.  In this case, if
  131.                       ;;; arguments are already pushed on the stack, then
  132.                       ;;; LOC cannot be NIL.  Callers of C2FUNCALL must be
  133.                       ;;; responsible for maintaining this condition.
  134.       (let ((*vs* *vs*) (form (caddr funob)))
  135.            (declare (object form))
  136.        (cond ((and (listp args)
  137.                *use-sfuncall*
  138.                ;;Determine if only one value at most is required:
  139.                (or
  140.             (eq *value-to-go* 'trash)
  141.             (and (consp *value-to-go*)
  142.                  (eq (car *value-to-go*) 'var))
  143.             (and info (equal (info-type info) '(values t)))
  144.             ))
  145.           (c2funcall-sfun form args info)
  146.           (return-from c2funcall nil)))
  147.            (unless loc
  148.              (unless (listp args) (baboon))
  149.              (cond ((eq (car form) 'LOCATION) (setq loc (caddr form)))
  150.                    ((and (eq (car form) 'VAR)
  151.                          (not (args-info-changed-vars (caaddr form) args)))
  152.                     (setq loc (cons 'VAR (caddr form))))
  153.                    (t
  154.                     (setq loc (list 'vs (vs-push)))
  155.                     (let ((*value-to-go* loc)) (c2expr* (caddr funob))))))
  156.            (push-args args)
  157.            (if *compiler-push-events*
  158.                (wt-nl "super_funcall(" loc ");")
  159.          (if *super-funcall*
  160.          (funcall *super-funcall* loc)
  161.                (wt-nl "super_funcall_no_event(" loc ");")))
  162.            (unwind-exit 'fun-val)))
  163.     (otherwise (baboon))
  164.     ))
  165.  
  166.  
  167. (defun fcalln-inline (&rest args &aux (f (car args)) length)
  168.   (wt #\()
  169.   (unless (and (consp f) (eq (car f) 'var))
  170.       (setq f (list 'cvar (cs-push)))
  171.       (wt-nl f " = " (car args) ","))
  172.    (wt-nl "(type_of(" f ") == t_sfun ?"
  173.       "(*(object (*)())((" f ")->sfn.sfn_self)):")
  174.    (when (< *space* 3)
  175.      (setq length t)
  176.      (wt-nl "(fcall.argd="  (length (cdr args)) ",type_of("f")==t_vfun) ?")
  177.      (wt-nl  "(*(object (*)())((" f ")->sfn.sfn_self)):"))
  178.    (wt-nl  "(fcall.fun=(" f "),")
  179.    (unless length
  180.        (wt "fcall.argd="  (length (cdr args)) ","))
  181.    (wt   "fcalln))(")
  182.    (when (cdr args) (wt (cadr args))
  183.      (dolist (loc (cddr args)) (wt #\, loc)))
  184.    (wt #\) #\)  ))
  185.  
  186. (defun c2call-lambda (lambda-expr args &aux (lambda-list (caddr lambda-expr)))
  187.   (declare (object lambda-list))
  188.   (cond ((or (cadr lambda-list)        ;;; Has optional?
  189.              (caddr lambda-list)    ;;; Has rest?
  190.              (cadddr lambda-list)    ;;; Has key?
  191.              (not (listp args))        ;;; Args already pushed?
  192.              )
  193.          (when (listp args)        ;;; Args already pushed?
  194.            (let ((*vs* *vs*) (base *vs*))
  195.                 (push-args-lispcall args)
  196.                 (when (need-to-set-vs-pointers lambda-list)
  197.                   (wt-nl "vs_top=(vs_base=base+" base ")+" (- *vs* base) ";")
  198.                   (base-used)
  199.                   )))
  200.          (c2lambda-expr lambda-list (caddr (cddr lambda-expr)))
  201.          )
  202.         (t
  203.      (let ((l-length (length (car lambda-list)))
  204.            (a-length (length args)))
  205.        (or (eql a-length l-length)
  206.          (cmperr "Calling lambda with ~a args not ~a" a-length
  207.              l-length)))
  208.           
  209.      (c2let (car lambda-list) args (caddr (cddr lambda-expr)))))
  210.   )
  211.  
  212. (defun check-fname-args (fname args)
  213.   (let ((a (get fname 'arg-types t)))
  214.     (and (eq t a) (get fname 'si::structure-access)
  215.      (setq a '(t)))
  216.     (cond ((and (listp a)
  217.         (listp args)
  218.         (not (member '* a)))
  219.        (or (eql (length a) (length args))
  220.            (cmpwarn "Wrong number of args for ~s: ~a instead of ~a."
  221.                 fname
  222.                 (length args) (length a)))))))
  223.  
  224. (defun save-avma (fd)
  225.   (when (and (not *restore-avma*)
  226.          (setq *restore-avma*
  227.          (or 
  228.           (member 'integer (car fd))
  229.           (eq (cadr fd) 'integer)
  230.           (flag-p (caddr fd) is))))
  231.     (wt-nl "{ save_avma;")
  232.     (inc-inline-blocks)
  233.     (or (consp *inline-blocks*)
  234.     (setq *inline-blocks* (cons  *inline-blocks* 'restore-avma)))))
  235.  
  236.     
  237.     
  238.  
  239.  
  240. (defun c2call-global (fname args loc return-type &aux fd (*vs* *vs*))
  241. ;this is now done in get-inline-info
  242. ;  (and  *Fast-link-compiling* (fast-link-proclaimed-type-p fname args)
  243. ;        (add-fast-link fname t args))
  244.   (if (inline-possible fname)
  245.     (cond 
  246.      ;;; Tail-recursive case.
  247.      ((and (listp args)
  248.            *do-tail-recursion*
  249.            *tail-recursion-info*
  250.            (eq (car *tail-recursion-info*) fname)
  251.            (member *exit*
  252.                    '(RETURN RETURN-FIXNUM RETURN-CHARACTER RETURN-SHORT-FLOAT
  253.                             RETURN-LONG-FLOAT RETURN-OBJECT))
  254.            (tail-recursion-possible)
  255.            (= (length args) (length (cdr *tail-recursion-info*))))
  256.       (let* ((*value-to-go* 'trash)
  257.              (*exit* (next-label))
  258.              (*unwind-exit* (cons *exit* *unwind-exit*)))
  259.             (c2psetq (mapcar #'(lambda (v) (list v nil))
  260.                              (cdr *tail-recursion-info*))
  261.                      args)
  262.             (wt-label *exit*))
  263.       (unwind-no-exit 'tail-recursion-mark)
  264.       (wt-nl "goto TTL;")
  265.       (cmpnote "Tail-recursive call of ~s was replaced by iteration." fname))
  266.  
  267.      ;;; Open-codable function call.
  268.      ((and (listp args)
  269.            (null loc)
  270.            (setq fd (get-inline-info fname args return-type)))
  271.       (let ((*inline-blocks* 0)
  272.         (*restore-avma*  *restore-avma*)) 
  273.     (save-avma fd)
  274.     (unwind-exit (get-inline-loc fd args) nil fname)
  275.     (close-inline-blocks)))
  276.  
  277.      ;;; Call to a function whose C language function name is known.
  278.      ((setq fd (or (get fname 'Lfun) (get fname 'Ufun)))
  279.       (check-fname-args fname args)
  280.       (push-args args)
  281.       (wt-nl fd "();")
  282.       (unwind-exit 'fun-val nil fname)
  283.       )
  284.  
  285.      ( t; *Fast-link-compiling*
  286.       (cond ((and
  287.                     (listp args)
  288.           (< (the fixnum (length args)) 10)
  289.           (or
  290.            *ifuncall*
  291.            (get fname 'ifuncall))
  292.                     (progn (if (eq *value-to-go* 'top) (format t "~%Called with top:~a" fname)) t)
  293.               (not (eq 'top *value-to-go*))
  294.           (null loc)
  295.           )
  296.          (let ((*inline-blocks* 0))
  297.            (unwind-exit (get-inline-loc  (inline-proc fname args) args)
  298.                 nil fname)
  299.            (close-inline-blocks)))
  300.         (t
  301.          (push-args args)
  302.          (let ((num (add-fast-link fname nil args)))
  303.            (wt-nl "(void) (*Lnk" num  ")(")
  304.            (if (get fname 'proclaimed-closure) (wt "Lclptr" num))
  305.            (wt  ");")
  306.            (unwind-exit 'fun-val nil fname)))))
  307.  
  308.  
  309.      ;;; Call to a function defined in the same file.
  310.      ((setq fd (assoc fname *global-funs*))
  311.       (push-args args)
  312.       (wt-nl "L" (cdr fd) "();")
  313.       (unwind-exit 'fun-val nil fname)
  314.       )
  315.      ((eql fname 'funcall-c)
  316.       (wt-funcall-c args))
  317.  
  318.      ;;; Otherwise.
  319.      (t (c2call-unknown-global fname args loc t)))
  320.     (c2call-unknown-global fname args loc nil))
  321.   )
  322.  
  323.  
  324.  
  325. (defun add-fast-link (fname type args)
  326.   (let (link link-info (n (add-symbol fname)) vararg)
  327.     (cond (type  
  328.        ;;should do some args checking in that case too.
  329.        (let* (link-string tem argtypes
  330.               (leng (and (listp args) (length args))))
  331.          (setq argtypes
  332.            (cond ((get fname 'proclaimed-function)
  333.               (get fname 'proclaimed-arg-types))
  334.              ((setq tem (get fname ' fixed-args))
  335.               (cond ((si:fixnump tem)
  336.                  (or (equal leng tem)
  337.                    (cmpwarn "~a: Fixed args not fixed!"
  338.                         fname)))
  339.                 (t (setf (get fname 'fixed-args) leng)))
  340.               (make-list leng :initial-element t))))
  341.          (and leng
  342.           (or (eql leng  (length argtypes))
  343.               (MEMBER '* ARGTYPES)
  344.               (cmpwarn "~a called with ~a args, expected ~a "
  345.                    fname leng
  346.                    (length argtypes))))
  347.          (unless
  348.           (cddr (setq link-info (assoc fname *function-links*)))
  349.           (setq link-string
  350.             (with-output-to-string
  351.              (st)
  352.             (format st  "(*(LnkLI~d))(" n)
  353.             (do ((com)
  354.              (v argtypes (cdr v))
  355.              (i 0 (+ 1 i)))
  356.             ((null v))
  357.             (cond ((eq (car v) '*)
  358.                    (setq vararg t)
  359.                    (princ "#*"  st))
  360.                   (t 
  361.                    (if com  (princ "," st) (setq com t))
  362.                    (format st "#~a" i))))
  363.             (princ ")" st)
  364.             )
  365.             )
  366. ;          (print (list 'link-string link-string))
  367. ;   (format t "~{~a~#[~:;,~]~}" '(1 2 3 4))
  368. ; 1,2,3,4
  369.  
  370.           (if vararg (setq link
  371.                     #'(lambda ( &rest l)
  372.                         (wt "(VFUN_NARGS="(length l) ",")
  373.                         (wt-inline-loc link-string l)
  374.                         (wt ")"))))
  375.                                
  376.           (push (list fname argtypes
  377.               (or (get fname 'proclaimed-return-type)
  378.                   t)
  379.               (flags side-effect-p allocates-new-storage)
  380.               (or link link-string) 'link-call)
  381.             *inline-functions*)
  382.           (setq link-info (list fname (format nil "LI~d" n)
  383.                     (or (get fname 'proclaimed-return-type)
  384.                     t)
  385.                      argtypes)))))
  386.       (t       
  387.        (check-fname-args fname args)
  388.        (setq link-info (list fname n
  389.                  (if (get fname 'proclaimed-closure) 'proclaimed-closure)
  390.                  ))))
  391.     (pushnew link-info    *function-links* :test 'equal)
  392.     n))
  393.  
  394. ;;make a function which will be called hopefully only once,
  395. ;;and will establish the link.
  396. (defun wt-function-link (x)
  397.   (let ((name (first x))
  398.     (num (second x))
  399.     (type (third x))
  400.     (args (fourth x)))
  401.     (cond
  402.       ((null type)
  403.        (wt-nl1 "static LnkT"
  404.            num "(){ call_or_link(VV[" num "],&Lnk" num");}"
  405.            ))
  406.       ((eql type 'proclaimed-closure)
  407.        (wt-nl1 "static LnkT" num
  408.            "(ptr) object *ptr;{ call_or_link_closure(VV[" num "],&Lnk" num",&Lclptr" num");}"))
  409.       (t
  410.        ;;change later to include above.
  411.        ;;(setq type (cdr (assoc type '((t . "object")(:btpr . "bptr")))))
  412.        (wt-nl1 "static " (rep-type type) " LnkT" num )
  413.        (cond ((or args (not (eq t type)))
  414.           (let ((vararg (member '* args)))
  415.         (wt "(va_alist)va_dcl{va_list ap;va_start(ap);return("
  416.             (rep-type type)")call_" (if vararg "v" "") "proc(VV["
  417.             (add-object name)"],&Lnk" num )
  418.         (or vararg (wt "," (proclaimed-argd args type)))
  419.         (wt   ",ap);}" )))
  420.          (t (wt "(){return call_proc0(VV[" (add-object name)
  421.             "],&Lnk" num ");}" ))))
  422.       (t (error "unknown link type ~a" type)))
  423.     (setq name (symbol-name name))
  424.     (if (find #\/ name) (setq name (remove #\/ name)))
  425.     (wt " /* " name " */")
  426.     ))
  427.       
  428.  
  429.  
  430. ;;For funcalling when the argument is guaranteed to be a compiled-function.
  431. ;;For (funcall-c he 3 4), he being a compiled function. (not a symbol)!
  432. (defun wt-funcall-c (args)
  433.   (let ((fun (car args))
  434.     (real-args (cdr args))
  435.     loc)
  436.     (cond ((eql (car fun) 'var)
  437.            (let ((fun-loc (cons (car fun) (third fun))))
  438.          (when *safe-compile*
  439.            (wt-nl "(type_of(")
  440.            (wt-loc fun-loc)
  441.            (wt ")==t_cfun)||FEinvalid_function(")
  442.            (wt-loc fun-loc)(wt ");"))
  443.        (push-args real-args)
  444.        (wt-nl "(")  
  445.        (wt-loc  fun-loc)))
  446.       (t
  447.        (setq loc (list 'cvar (incf *next-cvar*)))
  448.        (let ((*value-to-go* loc))
  449.          (wt-nl 
  450.           "{object V" (second loc) ";")
  451.          (c2expr* (car args))
  452.          (push-args (cdr args))
  453.          (wt "(V" (second loc)))))
  454.     (wt ")->cf.cf_self ();")
  455.     (and loc (wt "}")))
  456.   (unwind-exit 'fun-val))
  457.  
  458. (defun inline-proc (fname args &aux (n (length args)) res
  459.               (obj (add-object fname)))
  460.   (format t "~%Using ifuncall: ~a" fname)
  461.   (let ((result
  462.   (case n
  463.     ;(0  (list () t (flags ans set) (format nil "ifuncall0(VV[~d])" obj)))
  464.     (1 (list  '(t) t (flags ans set) (format nil "ifuncall1(VV[~d],(#0))" obj)
  465.           'ifuncall))
  466.     (2 (list  '(t t) t  (flags ans set) 
  467.                (format nil "ifuncall2(VV[~d],(#0),(#1))" obj)
  468.                'ifuncall))
  469.     (t
  470.      (list (make-list n :initial-element t)
  471.            t (flags ans set) 
  472.            (format nil "ifuncall(VV[~a],~a~{,#~a~})"
  473.                obj n
  474.                (dotimes (i n(nreverse res))
  475.                 (push i res)))
  476.            'ifuncall)))))
  477.     (push (cons fname result ) *inline-functions*)
  478.     result
  479.     ))
  480.  
  481.  
  482. (si:putprop 'simple-call 'wt-simple-call 'wt-loc)
  483.  
  484. (defun wt-simple-call (cfun base n &optional (vv-index nil))
  485.   (wt "simple_" cfun "(")
  486.   (when vv-index (wt "VV[" vv-index "],"))
  487.   (wt "base+" base "," n ")")
  488.   (base-used))
  489.  
  490. ;;; Functions that use SAVE-FUNOB should reset *vs*.
  491. (defun save-funob (funob)
  492.   (case (car funob)
  493.         ((call-lambda call-quote-lambda call-local))
  494.         (call-global
  495.          (unless (and (inline-possible (caddr funob))
  496.                       (or (get (caddr funob) 'Lfun)
  497.                           (get (caddr funob) 'Ufun)
  498.                           (assoc (caddr funob) *global-funs*)))
  499.            (let ((temp (list 'vs (vs-push))))
  500.                 (if *safe-compile*
  501.                     (wt-nl
  502.                      temp
  503.                      "=symbol_function(VV[" (add-symbol (caddr funob)) "]);")
  504.                     (wt-nl temp
  505.                            "=VV[" (add-symbol (caddr funob)) "]->s.s_gfdef;"))
  506.                 temp)))
  507.         (ordinary (let* ((temp (list 'vs (vs-push)))
  508.                          (*value-to-go* temp))
  509.                         (c2expr* (caddr funob))
  510.                         temp))
  511.         (otherwise (baboon))
  512.         ))
  513.  
  514. (defun push-args (args)
  515.   (cond ((null args) (wt-nl "vs_base=vs_top;"))
  516.         ((consp args)
  517.          (let ((*vs* *vs*) (base *vs*))
  518.            (dolist** (arg args)
  519.              (let ((*value-to-go* (list 'vs (vs-push))))
  520.                (c2expr* arg)))
  521.            (wt-nl "vs_top=(vs_base=base+" base ")+" (- *vs* base) ";")
  522.            (base-used)))))
  523.  
  524. (defun push-args-lispcall (args)
  525.   (dolist** (arg args)
  526.     (let ((*value-to-go* (list 'vs (vs-push))))
  527.       (c2expr* arg))))
  528.  
  529. (defun c2call-unknown-global (fname args loc inline-p)
  530.   (cond (*compiler-push-events*
  531.          ;;; Want to set up the return catcher.
  532.          (unless loc
  533.            (setq loc (list 'vs (vs-push)))
  534.            (wt-nl loc "=symbol_function(VV[" (add-symbol fname) "]);"))
  535.          (push-args args)
  536.          (wt-nl "funcall_with_catcher(VV[" (add-symbol fname) "]," loc  ");")
  537.          (unwind-exit 'fun-val nil fname))
  538.         (loc
  539.          ;;; The function was already pushed.
  540.          (push-args args)
  541.          (if inline-p
  542.              (if *safe-compile*
  543.                  (wt-nl "funcall_no_event(" loc ");")
  544.                  (wt-nl "CMPfuncall(" loc  ");"))
  545.              (wt-nl "funcall(" loc  ");"))
  546.          (unwind-exit 'fun-val))
  547.         ((args-cause-side-effect args)
  548.          ;;; Evaluation of the arguments may cause side-effect.
  549.          ;;; Arguments are not yet pushed.
  550.          (let ((base *vs*))
  551.               (setq loc (list 'vs (vs-push)))
  552.               (if *safe-compile*
  553.                   (wt-nl loc "=symbol_function(VV[" (add-symbol fname) "]);")
  554.                   (wt-nl loc "=(VV[" (add-symbol fname) "]->s.s_gfdef);"))
  555.               (push-args-lispcall args)
  556.               (cond ((or (eq *value-to-go* 'return)
  557.                          (eq *value-to-go* 'top))
  558.                      (wt-nl "lispcall")
  559.                      (when inline-p (wt "_no_event"))
  560.                      (wt "(base+" base "," (length args) ");")
  561.                      (base-used)
  562.                      (unwind-exit 'fun-val))
  563.                     (t (unwind-exit
  564.                         (list 'SIMPLE-CALL
  565.                               (if inline-p "lispcall_no_event" "lispcall")
  566.                               base (length args))))))
  567.          )
  568.         (t
  569.          ;;; Evaluation of the arguments causes no side-effect.
  570.          ;;; Arguments are not yet pushed.
  571.          (let ((base *vs*))
  572.               (push-args-lispcall args)
  573.               (cond ((or (eq *value-to-go* 'return)
  574.                          (eq *value-to-go* 'top))
  575.                      (wt-nl "symlispcall")
  576.                      (when inline-p (wt "_no_event"))
  577.                      (wt "(VV[" (add-symbol fname) "],base+" base ","
  578.                          (length args) ");")
  579.                      (base-used)
  580.                      (unwind-exit 'fun-val nil fname))
  581.                     (t (unwind-exit
  582.                         (list 'SIMPLE-CALL
  583.                           (if inline-p "symlispcall_no_event" "symlispcall")
  584.                           base (length args) (add-symbol fname))
  585.             nil fname))))
  586.          )))
  587.